home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / intrfc61.arc / RELOC.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-28  |  4KB  |  145 lines
  1. unit reloc;
  2. { unit to print relocation records }
  3.  
  4. interface
  5. uses dump,util,globals,loader,nametype,head;
  6.  
  7. type
  8.   reloc_ptr = ^reloc_rec;
  9.   reloc_rec = record
  10.     unit_num,            { offset to unit in unit block }
  11.     rtype : byte;
  12.     rblock,roffset,offset : word;
  13.   end;
  14.  
  15. const
  16.   code_seg  = 0;
  17.   code_data = 1;
  18.   var_seg   = 2;
  19.   const_seg = 3;
  20.  
  21. procedure print_reloc(seg:byte);
  22. procedure write_reloc_type(rtype:byte);
  23.  
  24. implementation
  25.  
  26. uses
  27.   blocks;
  28.  
  29. function ref_type(rtype:byte):byte;
  30. begin
  31.   ref_type := (rtype shr 4) and 3;
  32. end;
  33.  
  34. function target_type(rtype:byte):byte;
  35. begin
  36.   target_type := rtype shr 6;
  37. end;
  38.  
  39. procedure print_reloc(seg:byte);
  40. var
  41.   codebase,codeofs,codelimit,
  42.   base,ofs,limit : word;
  43.   block : reloc_ptr;
  44.   code_block : block_ptr;
  45.   target_unit : unit_list_ptr;
  46.   entry_pt : entry_pt_ptr;
  47.   target_unit_name : string;
  48.   fake_unit_info : unit_ptr;
  49. begin
  50.   case seg of
  51.   code_seg : begin
  52.         if header^.reloc_size = 0 then
  53.           exit;
  54.         writeln;
  55.         writeln('Code segment relocation records');
  56.         codebase :=header^.ofs_code_blocks;
  57.         codelimit := header^.ofs_const_blocks-codebase;
  58.      end;
  59.  
  60.   const_seg : begin
  61.         if header^.vmt_size = 0 then
  62.           exit;
  63.         writeln;
  64.         writeln('Const segment relocation records');
  65.         codebase :=header^.ofs_const_blocks;
  66.         codelimit := header^.ofs_var_blocks-codebase;
  67.      end;
  68.   end;
  69.   writeln('  Reloc');
  70.   writeln('  Offset  Fixup Type    Unit       Block:Offset');
  71.   base := 0;
  72.   codeofs := 0;
  73.   while codeofs < codelimit do
  74.   begin
  75.     code_block := add_offset(buffer,codebase+codeofs);
  76.     write('---');
  77.     case seg of
  78.       code_seg:  write_code_block_name(code_block^.owner);
  79.       const_seg: write_const_block_name(code_block^.owner);
  80.     end;
  81.     writeln('---');
  82.     ofs := 0;
  83.     limit := code_block^.relocbytes;
  84.     while ofs < limit do
  85.     begin
  86.       block := add_offset(reloc_buf,base+ofs);
  87.       with block^ do
  88.       begin
  89.         write(hexword2(codeofs),':',hexword(offset),' ');
  90.         write_reloc_type(rtype);
  91.  
  92.         target_unit_name := unit_name(unit_num);
  93.         write(target_unit_name:10);
  94.  
  95.         if target_type(rtype) = 0 then
  96.         begin
  97.           { It might be a good idea to try to add the unit to the unit_list
  98.             here, but I don't think so.  Let it fail if it wants to. }
  99.  
  100.           target_unit := get_unit_by_name(target_unit_name);
  101.  
  102.           if (target_unit <> nil) and (target_unit^.buffer <> nil) then
  103.             with target_unit^ do
  104.             begin
  105.               entry_pt := add_offset(buffer,
  106.                            header_ptr(buffer)^.ofs_entry_pts+rblock);
  107.               write(' ',hexword2(entry_pt^.code_block),':',
  108.                     hexword(entry_pt^.offset));
  109.             end
  110.           else
  111.             write(' entry',hexword(rblock));
  112.         end
  113.         else
  114.           write(' ',hexword2(rblock),':',hexword(roffset));
  115.         writeln;
  116.       end;
  117.       inc(ofs,sizeof(reloc_rec));
  118.     end;
  119.     inc(base,ofs);
  120.     inc(codeofs,sizeof(block_rec));
  121.   end;
  122. end;
  123.  
  124. procedure write_reloc_type(rtype:byte);
  125. begin
  126.   if (rtype and $0F) <> 0 then
  127.     write  ('Unknown type ',hexbyte(rtype):4);
  128.  
  129.   case ref_type(rtype) of
  130.   0 : write('Relative ');
  131.   1 : write('Offset   ');
  132.   2 : write('Segment  ');
  133.   3 : write('Pointer  ');
  134.   end;
  135.  
  136.   case target_type(rtype) of
  137.   code_seg  : write('Code    ');
  138.   code_data : write('CS Const');
  139.   var_seg   : write('Var     ');
  140.   const_seg : write('DS Const');
  141.   end;
  142. end;
  143.  
  144. end.
  145.